home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / AMICUS / AMICUS26.ADF / Tartan / Tartan5 < prev    next >
Text File  |  1989-01-26  |  7KB  |  354 lines
  1.  
  2. 'TARTAN AmigaBASIC program
  3. 'Richard Taylor   Glastonbury Conn
  4.  
  5. DEFINT a-z
  6. DEF FNL(h%,w,p)= INT(3+2*(h%+1)*INT((w+16)/16)*p/2)
  7. DIM sett(2,40),mx(4,4),ra$(2,20)
  8.  
  9. 'For initial checkout, use "depth=2"
  10. 'When checkout complete, use "depth=4"
  11. depth = 4
  12.  
  13. 'Set up the twill "weave" pattern
  14. FOR i = 1 TO 4: FOR j = 1 TO 4
  15.  READ mx(i,j) 
  16. NEXT j: NEXT i
  17. DATA 1,1,0,0,1,0,0,1,0,0,1,1,0,1,1,0
  18.  
  19. GOSUB InitRA
  20. IF depth > 2 THEN
  21.  SCREEN 1,640,200,depth,2
  22.  WINDOW 1,"TARTAN",,31,1
  23. END IF
  24.  
  25. 'Keep default colors 0-3
  26. 'Define colors 4-15
  27. FOR i = 4 TO 15 
  28.  READ r!,g!,b!
  29.  PALETTE i,r!,g!,b!
  30. NEXT i
  31. '    4=red   5=med red  6=brick    7=buff   
  32. DATA .9,0,0,  .64,0,0, .5,.2,.2, .75,.54,.29 
  33. '     8=green  9=med green  10=dk grn  11=yellow    
  34. DATA  0,.7,0,  .29,.54,.29, 0,.36,.11, .9,.9,0
  35. '    12=purple  13=dk prpl  14=lt blue  15=dk blue
  36. DATA .85,0,.85, .35,0,.45,  .5,.6,.8,  0,.18,.5 
  37.  
  38. MENU 1,0,0,"Project"
  39. MENU 1,1,1,"Control"
  40. MENU 1,2,1,"Quit   "
  41. MENU 2,0,0,""
  42. MENU 3,0,0,""
  43. MENU 4,0,0,""
  44.  
  45. ON MENU GOSUB L030
  46. MENU ON
  47. GOSUB Control
  48. L020:
  49. WHILE MOUSE(0) = 0: WEND  'Main Loop
  50. GOTO L020
  51.  
  52. L030:
  53. menuID = MENU(0)
  54. itemID = MENU(1)
  55. ON menuID  GOSUB L040
  56. RETURN
  57.  
  58. L040:
  59. IF itemID = 2 THEN
  60.  IF depth > 2 THEN
  61.   WINDOW CLOSE 1
  62.   SCREEN CLOSE 1
  63.   WINDOW 1,"BASIC",,31,-1
  64.  END IF 
  65.  MENU RESET
  66.  END
  67. END IF
  68. ON itemID GOSUB Control
  69. RETURN
  70.  
  71. 'Construct the Tartan and display it 
  72. Display:
  73. CLS: MENU 1,0,1
  74. 'Convert numeric characters of ra$
  75. 'to numeric digits in sett
  76. totLines = 0
  77. FOR i = 1 TO 2
  78.  FOR j = 1 TO ns
  79.   v = 0
  80.   FOR k = 1 TO 2
  81.    c$ = MID$(ra$(i,j),k,1)
  82.    IF c$ >= "0" AND c$ <= "9" THEN v = 10*v+ASC(c$)-48
  83.   NEXT k  
  84.   sett(i,j) = v
  85.   IF i = 1 THEN totLines = totLines + v
  86.  NEXT j
  87. NEXT i
  88.   
  89. 'Double the sett by appending its mirror image
  90. FOR i = 1 TO ns
  91.  j = 2*ns+1-i
  92.  sett(1,j) = sett(1,i)
  93.  sett(2,j) = sett(2,i)
  94. NEXT i 
  95. ns = 2*ns
  96.  
  97. ' "Weave" the basic square
  98. imx = 0: iy = 0
  99. FOR ia = 1 TO ns
  100.  nf = sett(1,ia)  'No. of weft lines
  101.  colf = sett(2,ia)  'Weft color
  102.  FOR ib = 1 TO nf  'Defines a weft line
  103.   imx = imx+1
  104.   IF imx > 4 THEN imx = 1
  105.   jmx = 0: iy = iy+1: ix = 0
  106.   
  107.   FOR ic = 1 TO ns
  108.    np = sett(1,ic)  'No. of warp lines
  109.    colp = sett(2,ic)  'Warp color
  110.    FOR id = 1 TO np  'Defines a warp line
  111.     jmx = jmx+1
  112.     IF jmx > 4 THEN jmx = 1
  113.     IF mx(imx,jmx) = 1 THEN col = colf ELSE col = colp
  114.     LINE (ix,iy)-(ix+2,iy),col
  115.     ix = ix+3
  116.    NEXT id
  117.   NEXT ic
  118.  NEXT ib
  119. NEXT ia
  120. IF totLines > 52 THEN L050
  121.  
  122. 'Fill the screen
  123. iz = FNL(iy+1,ix+1,depth)
  124. DIM a(iz)
  125. GET (0,0)-(ix,iy),a
  126. ixn = INT(640/ix)
  127. iyn = INT(200/iy)
  128. CLS
  129. FOR i = 0 TO ixn*ix STEP ix
  130.  FOR j = 0 TO iyn*iy STEP iy
  131.   PUT (i,j),a
  132.  NEXT j
  133. NEXT i
  134. ERASE a
  135. L050:
  136.  ns = ns/2
  137. RETURN
  138.  
  139. 'Show TARTAN CONTROL panel
  140. Control:
  141. CLS: MENU 1,0,0
  142. LOCATE 4,1
  143. j = 14
  144. FOR i = 0 TO 2^depth-1
  145.  PRINT TAB(j);i;
  146.  j = j+4
  147. ' IF i < 8 THEN k=i ELSE k=i-8
  148.  LINE (33*i+94,10)-(33*(i+1)+94,20),i,bf
  149. NEXT i
  150. LINE (93,9)-(617,21),2,b
  151. LOCATE 1,20: PRINT "- - - - C o l o r   M e n u - - - -"
  152. COLOR 3,2   
  153. LOCATE 2,2: PRINT " TARTAN  " 
  154. LOCATE 3,2: PRINT " CONTROL "
  155. COLOR 1,0
  156. LOCATE 5,3: PRINT "0"
  157. LINE (8,29)-(32,42),,b
  158. LOCATE 6,6: PRINT "Lines Color"
  159. ef = 0: GOSUB PData
  160. L150:  
  161. COLOR 2,3
  162. LINE (8,138)-(80,156),3,bf
  163. LOCATE 19,3: PRINT "DISPLAY"
  164. LINE (105,138)-(145,156),3,bf
  165. LOCATE 19,15: PRINT "NEW"
  166. LINE (184,138)-(246,156),3,bf
  167. LOCATE 19,25: PRINT "CHANGE"
  168. LINE (264,138)-(326,156),3,bf
  169. LOCATE 19,35: PRINT "DELETE"
  170. LINE (344,138)-(406,156),3,bf
  171. LOCATE 19,45: PRINT "INSERT"
  172. COLOR 1,0
  173. LOCATE 17,36: PRINT "EDIT"
  174. LINE (174,126)-(416,164),,b
  175.  
  176. L160:
  177. COLOR 1,0: WHILE MOUSE(0) = 0: WEND
  178. IF MOUSE(0) = 0 THEN L160
  179. xm = MOUSE(1): ym = MOUSE(2)
  180. IF ym >= 138 AND ym <= 156 THEN
  181.  IF xm >= 8 AND xm <= 80 THEN     'Display
  182.   IF ns < 2 THEN
  183.    msg$ = "Need 2 or more items for DISPLAY."
  184.    GOSUB ErrPrt: GOTO L160
  185.   END IF
  186.   GOTO L170
  187.  END IF  
  188.  IF xm >= 105 AND xm <= 145 THEN  'New
  189.   GOSUB InitRA
  190.   CLS: ns = 0
  191.   GOTO Control
  192.  END IF: COLOR 3,2
  193.  IF xm >= 184 AND xm <= 246 THEN  'Change
  194.   LOCATE 19,25: PRINT "CHANGE"
  195.   F$ = "C": GOTO L160
  196.  END IF
  197.  IF xm >= 264 AND xm <= 326 THEN  'Delete
  198.   LOCATE 19,35: PRINT "DELETE"
  199.   F$ = "D": GOTO L160
  200.  END IF
  201.  IF xm >= 344 AND xm <= 406 THEN  'Insert
  202.   IF ns = 20 THEN
  203.    msg$ = "Max of 20 items allowed."
  204.    GOSUB ErrPrt: GOTO L160
  205.   END IF 
  206.   LOCATE 19,45: PRINT "INSERT"
  207.   F$ = "I": GOTO L160
  208.  END IF        
  209. END IF
  210.  
  211. IF F$ = "C" OR F$ = "D" OR F$ = "I" THEN
  212.  IF xm < 8 OR xm > 470 THEN L160
  213.  IF ym < 29 OR ym > 122 THEN L160
  214.  xp = 8: yp = 13: xL = 2
  215.  FOR k = 0 TO ns
  216.   GOSUB BoxC
  217.   IF xm >= xp AND xm <= xp+24 THEN
  218.   IF ym >= yp AND ym <= yp+13 THEN
  219.    IF F$ = "C" AND k > 0 THEN  'Change
  220.     ef = k: GOSUB PData
  221.     F$ = "": GOTO L150
  222.    END IF   
  223.    IF F$ = "D" AND k > 0 THEN  'Delete
  224.     FOR j = k+1 TO ns
  225.      ra$(1,j-1) = ra$(1,j)
  226.      ra$(2,j-1) = ra$(2,j)
  227.     NEXT j
  228.     ns = ns-1: F$ = ""
  229.     GOTO Control
  230.    END IF
  231.    IF F$ = "I" THEN            'Insert
  232.     FOR j = ns TO k+1 STEP -1
  233.      ra$(1,j+1) = ra$(1,j)
  234.      ra$(2,j+1) = ra$(2,j)
  235.     NEXT j
  236.     ns = ns+1: ef = k+1
  237.     ra$(1,ef) = "00": ra$(2,ef) = "00"
  238.     GOSUB PData
  239.     F$ = "": GOTO L150
  240.    END IF    
  241.   END IF
  242.   END IF
  243.  NEXT k
  244. END IF 
  245. GOTO L160
  246. L170:
  247. ef = 0
  248. GOSUB Display
  249. RETURN
  250.  
  251. 'Calc item box coordinates
  252. BoxC:
  253. yp = yp+16: yL = yL+2
  254. IF yp > 109 THEN
  255.  xp = xp+146: yp = 45
  256.  xL = xL+18: yL = 7
  257.  LOCATE 6,xL+4: PRINT "Lines Color"
  258. END IF
  259. RETURN
  260.  
  261. 'Initialize ra$ array
  262. InitRA:
  263. FOR i = 1 TO 2
  264.  FOR j = 1 TO 20
  265.   ra$(i,j) = "00"
  266.  NEXT j
  267. NEXT i
  268. RETURN  
  269.  
  270. 'Print error message
  271. ErrPrt:
  272. BEEP: LOCATE 21,1: PRINT msg$
  273. INPUT "Press RETURN to continue.",a$
  274. LOCATE 21,1: PRINT SPACE$(33)
  275. PRINT SPACE$(25): RETURN
  276.  
  277. 'Process items--input, change, insert
  278. PData:
  279. sxp = 0: xp = 8: yp = 29: xL = 2: yL = 5
  280. IF ns = 0 THEN kk = 20 ELSE kk = ns
  281. FOR i = 1 TO kk
  282.  GOSUB BoxC
  283.  IF ns = 0 THEN 
  284.   LOCATE yL,xL: PRINT i
  285.   LINE (xp,yp)-(xp+24,yp+13),,b
  286.   CALL DataSub(xL+5,yL,ra$(1,i))
  287.   IF ra$(1,i) = "" THEN
  288.    ns = i-1: GOTO L270
  289.   END IF 
  290.   CALL DataSub(xL+10,yL,ra$(2,i))
  291.   GOTO L260
  292.  END IF
  293.  IF ef = 0 THEN
  294. L250: 
  295.   LOCATE yL,xL: PRINT i
  296.   LINE (xp,yp)-(xp+24,yp+13),,b
  297.   LOCATE yL,xL+5: PRINT ra$(1,i);" "
  298.   LOCATE yL,xL+10: PRINT ra$(2,i);" "
  299.   GOTO L260
  300.  END IF
  301.  IF i < ef THEN L260
  302.  IF i > ef THEN L250
  303.  IF ra$(1,i) <> "00" THEN
  304.   CALL DataSub(xL+5,yL,ra$(1,i))
  305.   CALL DataSub (xL+10,yL,ra$(2,i))
  306.   GOTO L270
  307.  END IF
  308.  sxp = xp: syp = yp: si = i
  309.  sxL = xL: syL = yL 
  310. L260:  
  311. NEXT i
  312. IF ns = 0 THEN ns = 20
  313. IF sxp > 0 THEN
  314.  IF si = ns THEN
  315.   LOCATE syL,sxL: PRINT ns
  316.   LINE (sxp,syp)-(sxp+24,syp+13),,b
  317.  END IF
  318.  CALL DataSub(sxL+5,syL,ra$(1,si))
  319.  CALL DataSub(sxL+10,syL,ra$(2,si))
  320. END IF
  321. L270:
  322. RETURN  
  323.  
  324. 'Data entry for "Lines" & "Color"
  325. SUB DataSub(xx,yy,d$) STATIC
  326. COLOR 2,1
  327. IF d$ = "00" THEN
  328.  LOCATE yy,xx: PRINT "  "
  329.  d$ = ""
  330. END IF 
  331. cur = LEN(d$)
  332. k$ = ""
  333. WHILE k$ <> CHR$(13)
  334.  LOCATE yy,xx: PRINT d$;
  335.  k$ = ""
  336.  WHILE k$ = "": k$ = INPUT$(1): WEND
  337.  k = ASC(k$)
  338.  IF k >= 48 AND k <= 57 AND cur < 2 THEN
  339.   d$ = LEFT$(d$,cur)+k$
  340.   cur = cur+1
  341.  END IF
  342.  IF k = 8 THEN
  343.   IF cur > 0 THEN d$ = LEFT$(d$,cur-1)
  344.   LOCATE yy,xx: PRINT "  "
  345.   IF cur > 0 THEN cur = cur-1
  346.  END IF 
  347. WEND
  348. COLOR 1,0
  349. LOCATE yy,xx: PRINT "  "
  350. LOCATE yy,xx: PRINT d$
  351. END SUB
  352.  
  353.  
  354.